{
  $Id: Jpeg2000VCL.pas 8 2010-09-21 21:56:14Z marekmauder $
  PasJpeg2000 by Marek Mauder
  http://code.google.com/p/pasjpeg2000
  http://galfar.vevb.net/pasjpeg2000

  The contents of this file are used with permission, subject to the Mozilla
  Public License Version 1.1 (the "License"); you may not use this file except
  in compliance with the License. You may obtain a copy of the License at
  http://www.mozilla.org/MPL/MPL-1.1.html

  Software distributed under the License is distributed on an "AS IS" basis,
  WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for
  the specific language governing rights and limitations under the License.

  Alternatively, the contents of this file may be used under the terms of the
  GNU Lesser General Public License (the  "LGPL License"), in which case the
  provisions of the LGPL License are applicable instead of those above.
  If you wish to allow use of your version of this file only under the terms
  of the LGPL License and not to allow others to use your version of this file
  under the MPL, indicate your decision by deleting  the provisions above and
  replace  them with the notice and other provisions required by the LGPL
  License.  If you do not delete the provisions above, a recipient may use
  your version of this file under either the MPL or the LGPL License.

  For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html
}

{ Jpeg 2000 graphic class (TGraphic) for Delphi VCL. }

unit Jpeg2000VCL;

{$IFDEF FPC}
  {$ERROR 'This unit is for Delphi VCL only'}
{$ENDIF}

interface

uses
  Windows, SysUtils, Classes, Graphics, Jpeg2000ImageIO;

type
  EJpeg2000BitmapError = class(Exception);

  TJpeg2000Bitmap = class(TBitmap)
  private
    FOptions: TJpeg2000Options;
  public
    constructor Create; override;
    destructor Destroy; override;

    procedure LoadFromStream(Stream: TStream); override;
    procedure SaveToStream(Stream: TStream); override;

    property Options: TJpeg2000Options read FOptions;
  end;

implementation

resourcestring
  SJpeg2000ImageFile = 'JPEG 2000 Image';
  SComponentNotFound = 'Requested component/channel not found in source JPEG 2000 image.';

{ TJpeg2000Bitmap }

constructor TJpeg2000Bitmap.Create;
begin
  inherited;
  FOptions := TJpeg2000Options.Create;
end;

destructor TJpeg2000Bitmap.Destroy;
begin
  FOptions.Free;
  inherited;
end;

procedure TJpeg2000Bitmap.LoadFromStream(Stream: TStream);
var
  IO: TJpeg2000ImageIO;
  NewPF: TPixelFormat;
  Y, BytesPerPixel: Integer;

  procedure DeterminePixelFormatAndBpp(var PF: TPixelFormat; var Bpp: Integer);
  begin
    PF := pf32bit;
    Bpp := 4;

    case IO.ComponentCount of
      1:
        begin
          PF := pf8bit;
          Bpp := 1;
        end;
      3:
        begin
          PF := pf24bit;
          Bpp := 3;
        end;
    end;
  end;

  procedure ReadComponent(const Types: array of TJpeg2000ComponentType; ScanIdx, Stride: Integer);
  var
    CompIdx, I: Integer;
  begin
    for I := 0 to Length(Types) - 1 do
    begin
      CompIdx := I;
      if Types[I] <> cpUnknown then
        CompIdx := IO.GetComponentTypeIndex(Types[I]);
      if CompIdx >= IO.ComponentCount then
        CompIdx := IO.ComponentCount - 1;

      if CompIdx < 0 then
        raise EJpeg2000BitmapError.Create(SComponentNotFound);

      IO.GetComponentData(CompIdx, @PByteArray(ScanLine[ScanIdx])[I], Y, Stride, 8);
    end;
  end;

  procedure SetupPalette;
  var
    I: Integer;
    LogPalette: TMaxLogPalette;
  begin
    FillChar(LogPalette, SizeOf(LogPalette), 0);
    LogPalette.palVersion := $300;
    LogPalette.palNumEntries := 256;

    if IO.ColorSpace = csIndexed then
    begin
      // Read palette from decoded image

    end
    else
    begin
      // Create linear palette for luminance and unknown formats
      for I := 0 to 255 do
      with LogPalette do
      begin
        palPalEntry[I].peRed :=   I;
        palPalEntry[I].peGreen := I;
        palPalEntry[I].peBlue :=  I;
      end;
    end;

    Self.Palette := CreatePalette(PLogPalette(@LogPalette)^);
  end;

  procedure ConvertFromYCC;
  var
    X, I: Integer;
    Ptr: PByteArray;
    Yc, Cb, Cr: Byte;
  begin
    for I := 0 to Height - 1 do
    begin
      Ptr := ScanLine[I];
      for X := 0 to Width - 1 do
      begin
        Yc := Ptr[2];
        Cb := Ptr[1];
        Cr := Ptr[0];
        YCbCrToRGB(Yc, Cb, Cr, Ptr[2], Ptr[1], Ptr[0]);
        Ptr := @Ptr[BytesPerPixel];
      end;
    end;
  end;

  procedure ConvertFromCMYK;
  var
    X, I: Integer;
    Ptr: PByteArray;
    C, M, Y, K: Byte;
  begin
    for I := 0 to Height - 1 do
    begin
      Ptr := ScanLine[I];
      for X := 0 to Width - 1 do
      begin
        C := Ptr[3];
        M := Ptr[2];
        Y := Ptr[1];
        K := Ptr[0];
        CMYKToRGB(C, M, Y, K, Ptr[2], Ptr[1], Ptr[0]);
        Ptr := @Ptr[BytesPerPixel];
      end;
    end;
  end;

  procedure SwapRedAndBlue;
  var
    X, Y: Integer;
    Ptr: PByteArray;
    Tmp: Byte;
  begin
    for Y := 0 to Height - 1 do
    begin
      Ptr := ScanLine[Y];
      for X := 0 to Width - 1 do
      begin
        Tmp := Ptr[2];
        Ptr[2] := Ptr[0];
        Ptr[0] := Tmp;
        Ptr := @Ptr[BytesPerPixel];
      end;
    end;
  end;

begin
  IO := TJpeg2000ImageIO.Create;
  try
    IO.ReadFromStream(Stream);

    DeterminePixelFormatAndBpp(NewPF, BytesPerPixel);
    PixelFormat := NewPF;
  {$IF CompilerVersion >= 18.0}
    SetSize(IO.Width, IO.Height);
  {$ELSE}
    Width := IO.Width;
    Height := IO.Height;
  {$IFEND}

    // 8bit bitmaps need palette to be set up before pixels are written
    if PixelFormat = pf8Bit then
      SetupPalette;

    // Now read scanlines from decoded JPEG 2000 image base on pixel format
    // and color space
    for Y := 0 to Height - 1 do
    begin
      FillChar(ScanLine[Y]^, Width * BytesPerPixel, 0);

      case NewPF of
        pf8bit:
          case IO.ColorSpace of
            csLuminance: ReadComponent([cpLuminance], Y, 1);
            csIndexed:   ReadComponent([cpIndex], Y, 1);
          else
            ReadComponent([cpUnknown], Y, 1);
          end;

        pf24bit:
          case IO.ColorSpace of
            csRGB:   ReadComponent([cpBlue, cpGreen, cpRed], Y, 3);
            csYCbCr: ReadComponent([cpChromaRed, cpChromaBlue, cpLuminance], Y, 3);
          else
            ReadComponent([cpUnknown, cpUnknown, cpUnknown], Y, 3);
          end;

        pf32bit:
          case IO.ColorSpace of
            csLuminance: ReadComponent([cpLuminance, cpLuminance, cpLuminance, cpOpacity], Y, 4);  // Luminance+Alpha
            csRGB:       ReadComponent([cpBlue, cpGreen, cpRed, cpOpacity], Y, 4);                 // Standard RGB+Alpha
            csYCbCr:     ReadComponent([cpChromaRed, cpChromaBlue, cpLuminance, cpOpacity], Y, 4); // YCC+Alpha
            csCMYK:      ReadComponent([cpBlack, cpYellow, cpMagenta, cpCyan], Y, 4);              // CMYK
          else
            ReadComponent([cpUnknown, cpUnknown, cpUnknown, cpUnknown], Y, 4);
          end;
      end;
    end;

    // Convert to RGB colorspace if needed
    case IO.ColorSpace of
      csYCbCr:   ConvertFromYCC;
      csCMYK:    ConvertFromCMYK;
      csUnknown: SwapRedAndBlue; // Just for convenience (raw code streams, ICC profiles, etc.)
    end;

  {$IF CompilerVersion >= 20.0}
    // Delphi 2009 and newer support alpha transparency
    if (PixelFormat = pf32bit) and IO.HasOpacity then
      AlphaFormat := afDefined;
  {$IFEND}

  finally
    IO.Free;
  end;
end;

procedure TJpeg2000Bitmap.SaveToStream(Stream: TStream);
var
  IO: TJpeg2000ImageIO;
  WorkBmp: TBitmap;
  ComponentCount, Y: Integer;
  ColorSpace: TJpeg2000ColorSpace;

  procedure DefineComponents(const Types: array of TJpeg2000ComponentType);
  var
    I: Integer;
  begin
    for I := 0 to Length(Types) - 1 do
      IO.DefineComponent(I, WorkBmp.Width, WorkBmp.Height, 8, Types[I], 1, 1);
  end;

  procedure WriteComponents(const Types: array of TJpeg2000ComponentType; ScanIdx, Stride: Integer);
  var
    CompIdx, I: Integer;
  begin
    for I := 0 to Length(Types) - 1 do
    begin
      CompIdx := I;
      if Types[I] <> cpUnknown then
        CompIdx := IO.GetComponentTypeIndex(Types[I]);
      if CompIdx >= IO.ComponentCount then
        CompIdx := IO.ComponentCount - 1;

      if CompIdx < 0 then
        raise EJpeg2000BitmapError.Create(SComponentNotFound);

      IO.SetComponentData(CompIdx, @PByteArray(ScanLine[ScanIdx])[I], Y, Stride);
    end;
  end;

begin
  IO := TJpeg2000ImageIO.Create;
  try
    // Saving only supports 8/24/32bit bitmaps. For incompatible pixel formats
    // temp working bitmap is created.
    if not (PixelFormat in [pf8bit, pf24bit, pf32bit]) then
    begin
      WorkBmp := TBitmap.Create;
      WorkBmp.Assign(Self);
      WorkBmp.PixelFormat := pf24bit;
    end
    else
      WorkBmp := Self;

    ColorSpace := csRGB;
    ComponentCount := 3;
    case WorkBmp.PixelFormat of
      pf8bit:  ComponentCount := 1;
      pf32bit: ComponentCount := 4;
    end;

    IO.BeginNewImage(WorkBmp.Width, WorkBmp.Height, ColorSpace, ComponentCount = 4);
    case WorkBmp.PixelFormat of
      pf8bit:  DefineComponents([cpLuminance]);
      pf24bit: DefineComponents([cpBlue, cpGreen, cpRed]);
      pf32bit: DefineComponents([cpBlue, cpGreen, cpRed, cpOpacity]);
    end;
    IO.BuildNewImage;

    for Y := 0 to Height - 1 do
    begin
      case WorkBmp.PixelFormat of
        pf8bit:  WriteComponents([cpLuminance], Y, 1);
        pf24bit: WriteComponents([cpBlue, cpGreen, cpRed], Y, 3);
        pf32bit: WriteComponents([cpBlue, cpGreen, cpRed, cpOpacity], Y, 4);
      end;
    end;

    // Assign JPEG2000 IO options and write to stream
    IO.Options.Assign(Options);
    IO.WriteToStream(Stream);
  finally
    IO.Free;
    if WorkBmp <> Self then
      WorkBmp.Free;
  end;
end;

initialization
  TPicture.RegisterFileFormat('jp2', SJpeg2000ImageFile, TJpeg2000Bitmap);
  TPicture.RegisterFileFormat('j2k', SJpeg2000ImageFile, TJpeg2000Bitmap);
  TPicture.RegisterFileFormat('jpc', SJpeg2000ImageFile, TJpeg2000Bitmap);
finalization
  TPicture.UnregisterGraphicClass(TJpeg2000Bitmap);
end.
